Mercurial > forge
changeset 8249:2205fcc1aa6b octave-forge
control: clean up ncfsyn
| author | paramaniac |
|---|---|
| date | Fri, 05 Aug 2011 12:34:08 +0000 |
| parents | d0708b65ffa5 |
| children | 07995dc304c2 |
| files | main/control/INDEX main/control/devel/MDSSystem.m main/control/devel/makefile_all.m main/control/devel/makefile_ncfsyn.m main/control/devel/ncfsyn/MA02AD.f main/control/devel/ncfsyn/MA02ED.f main/control/devel/ncfsyn/MA02GD.f main/control/devel/ncfsyn/MB01RU.f main/control/devel/ncfsyn/MB01RX.f main/control/devel/ncfsyn/MB01RY.f main/control/devel/ncfsyn/MB01SD.f main/control/devel/ncfsyn/MB01UD.f main/control/devel/ncfsyn/MB02PD.f main/control/devel/ncfsyn/MB02VD.f main/control/devel/ncfsyn/SB02MR.f main/control/devel/ncfsyn/SB02MS.f main/control/devel/ncfsyn/SB02MV.f main/control/devel/ncfsyn/SB02MW.f main/control/devel/ncfsyn/SB02OD.f main/control/devel/ncfsyn/SB02OU.f main/control/devel/ncfsyn/SB02OV.f main/control/devel/ncfsyn/SB02OW.f main/control/devel/ncfsyn/SB02OY.f main/control/devel/ncfsyn/SB02QD.f main/control/devel/ncfsyn/SB02RD.f main/control/devel/ncfsyn/SB02RU.f main/control/devel/ncfsyn/SB02SD.f main/control/devel/ncfsyn/SB03MV.f main/control/devel/ncfsyn/SB03MW.f main/control/devel/ncfsyn/SB03MX.f main/control/devel/ncfsyn/SB03MY.f main/control/devel/ncfsyn/SB03QX.f main/control/devel/ncfsyn/SB03QY.f main/control/devel/ncfsyn/SB03SX.f main/control/devel/ncfsyn/SB03SY.f main/control/devel/ncfsyn/SB04PX.f main/control/devel/ncfsyn/select.f main/control/doc/NEWS main/control/inst/MDSSystem.m |
| diffstat | 39 files changed, 201 insertions(+), 12267 deletions(-) [+] |
line wrap: on
line diff
--- a/main/control/INDEX Fri Aug 05 12:14:15 2011 +0000 +++ b/main/control/INDEX Fri Aug 05 12:34:08 2011 +0000 @@ -80,6 +80,7 @@ h2syn hinfsyn mixsyn + ncfsyn Matrix Equation Solvers care dare
--- a/main/control/devel/MDSSystem.m Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,156 +0,0 @@ -% =============================================================================== -% 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(4, 4); % 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 -figure (1) - -for k = 1 : numel (delta_m) - Delta = diag ([delta_m(k), delta_c(k), delta_k(k)]); - G_per = lft (Delta, G_nom); - bode (G_per, w) - subplot (2, 1, 1) - hold on - subplot (2, 1, 2) - hold on -endfor - - -% =============================================================================== -% 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 = mixsyn (G, W_p, W_u); % mixed-sensitivity H-infinity synthesis - -% Interconnections -L = G * K; % open loop -T = feedback (L); % closed loop - -% Plotting -figure (2) -sigma (T) % singular values - -figure (3) -step (T) % step response - - -% =============================================================================== -% H-infinity Loop-Shaping Design -% =============================================================================== - -% Settings -W1 = 8 * (2*s + 1) / (0.9*s); % precompensator -W2 = 1; % postcompensator -factor = 1.1; % suboptimal controller - -% Synthesis -K = ncfsyn (G, W1, W2, factor); % positive feedback controller - -% Interconnections -K = -K; % negative feedback controller -L = G * K; % open loop -T = feedback (L); % closed loop - -% Plotting -figure (4) -sigma (T) % singular values - -figure (5) -step (T) % step response - -% ===============================================================================
--- a/main/control/devel/makefile_all.m Fri Aug 05 12:14:15 2011 +0000 +++ b/main/control/devel/makefile_all.m Fri Aug 05 12:34:08 2011 +0000 @@ -19,6 +19,7 @@ makefile_lqr makefile_lyap makefile_minreal +makefile_ncfsyn makefile_norm makefile_place makefile_scale
--- a/main/control/devel/makefile_ncfsyn.m Fri Aug 05 12:14:15 2011 +0000 +++ b/main/control/devel/makefile_ncfsyn.m Fri Aug 05 12:34:08 2011 +0000 @@ -1,3 +1,19 @@ +## ============================================================================== +## Developer Makefile for OCT-files +## ============================================================================== +## USAGE: * fetch control from Octave-Forge by svn +## * add control/inst, control/src and control/devel to your Octave path +## * run makefile_* +## NOTES: * The option "-Wl,-framework" "-Wl,vecLib" is needed for MacPorts' +## octave-devel @3.3.52_1+gcc44 on MacOS X 10.6.4. However, this option +## breaks other platforms. See MacPorts Ticket #26640. +## ============================================================================== + +homedir = pwd (); +develdir = fileparts (which ("makefile_ncfsyn")); +srcdir = [develdir, "/../src"]; +cd (srcdir); + ## H-infinity loop shaping - continuous-time mkoctfile "-Wl,-framework" "-Wl,vecLib" \ slsb10id.cc \ @@ -19,4 +35,6 @@ slsb10zd.cc \ SB10ZD.f MA02AD.f SB02OD.f select.f MB01RX.f \ MB02VD.f SB02OY.f SB02OW.f SB02OV.f SB02OU.f \ - SB02MR.f MA02GD.f SB02MV.f \ No newline at end of file + SB02MR.f MA02GD.f SB02MV.f + +cd (homedir);
--- a/main/control/devel/ncfsyn/MA02AD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,108 +0,0 @@ - SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/MA02ED.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,99 +0,0 @@ - SUBROUTINE MA02ED( UPLO, N, A, LDA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To store by symmetry the upper or lower triangle of a symmetric -C matrix, given the other triangle. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which part of the matrix is given as follows: -C = 'U': Upper triangular part; -C = 'L': Lower triangular part. -C For all other values, the array A is not referenced. -C -C Input/Output Parameters -C -C N (input) INTEGER -C The order of the matrix A. N >= 0. -C -C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -C On entry, the leading N-by-N upper triangular part -C (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'), -C of this array must contain the corresponding upper or -C lower triangle of the symmetric matrix A. -C On exit, the leading N-by-N part of this array contains -C the symmetric matrix A with all elements stored. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,N). -C -C CONTRIBUTOR -C -C V. Sima, Research Institute for Informatics, Bucharest, Romania, -C Oct. 1998. -C -C REVISIONS -C -C - -C -C ****************************************************************** -C -C .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*) -C .. Local Scalars .. - INTEGER J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DCOPY -C -C .. Executable Statements .. -C -C For efficiency reasons, the parameters are not checked for errors. -C - IF( LSAME( UPLO, 'L' ) ) THEN -C -C Construct the upper triangle of A. -C - DO 20 J = 2, N - CALL DCOPY( J-1, A(J,1), LDA, A(1,J), 1 ) - 20 CONTINUE -C - ELSE IF( LSAME( UPLO, 'U' ) ) THEN -C -C Construct the lower triangle of A. -C - DO 40 J = 2, N - CALL DCOPY( J-1, A(1,J), 1, A(J,1), LDA ) - 40 CONTINUE -C - END IF - RETURN -C *** Last line of MA02ED *** - END
--- a/main/control/devel/ncfsyn/MA02GD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,158 +0,0 @@ - SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/MB01RU.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,282 +0,0 @@ - SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, - $ X, LDX, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To compute the matrix formula -C _ -C R = alpha*R + beta*op( A )*X*op( A )', -C _ -C where alpha and beta are scalars, R, X, and R are symmetric -C matrices, A is a general matrix, and op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C UPLO CHARACTER*1 -C Specifies which triangles of the symmetric matrices R -C and X are given as follows: -C = 'U': the upper triangular part is given; -C = 'L': the lower triangular part is given. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R and the number of rows -C of the matrix op( A ). M >= 0. -C -C N (input) INTEGER -C The order of the matrix X and the number of columns of the -C the matrix op( A ). N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry, except when R is identified with X in -C the call. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and X are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix R. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix R. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k) -C where k is N when TRANS = 'N' and is M when TRANS = 'T' or -C TRANS = 'C'. -C On entry with TRANS = 'N', the leading M-by-N part of this -C array must contain the matrix A. -C On entry with TRANS = 'T' or TRANS = 'C', the leading -C N-by-M part of this array must contain the matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,k), -C where k is M when TRANS = 'N' and is N when TRANS = 'T' or -C TRANS = 'C'. -C -C X (input) DOUBLE PRECISION array, dimension (LDX,N) -C On entry, if UPLO = 'U', the leading N-by-N upper -C triangular part of this array must contain the upper -C triangular part of the symmetric matrix X and the strictly -C lower triangular part of the array is not referenced. -C On entry, if UPLO = 'L', the leading N-by-N lower -C triangular part of this array must contain the lower -C triangular part of the symmetric matrix X and the strictly -C upper triangular part of the array is not referenced. -C The diagonal elements of this array are modified -C internally, but are restored on exit. -C -C LDX INTEGER -C The leading dimension of array X. LDX >= MAX(1,N). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C This array is not referenced when beta = 0, or M*N = 0. -C -C LDWORK The length of the array DWORK. -C LDWORK >= M*N, if beta <> 0; -C LDWORK >= 0, if beta = 0. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -k, the k-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the symmetry -C into account. Specifically, let X = T + T', with T an upper or -C lower triangular matrix, defined by -C -C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', -C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', -C -C where triu, tril, and diag denote the upper triangular part, lower -C triangular part, and diagonal part of X, respectively. Then, -C -C A*X*A' = ( A*T )*A' + A*( A*T )', for TRANS = 'N', -C A'*X*A = A'*( T*A ) + ( T*A )'*A, for TRANS = 'T', or 'C', -C -C which involve BLAS 3 operations (DTRMM and DSYR2K). -C -C NUMERICAL ASPECTS -C -C The algorithm requires approximately -C -C 2 2 -C 3/2 x M x N + 1/2 x M -C -C operations. -C -C FURTHER COMMENTS -C -C This is a simpler version for MB01RD. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1999. -C -C REVISIONS -C -C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2004. -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, HALF - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, - $ HALF = 0.5D0 ) -C .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) -C .. Local Scalars .. - LOGICAL LTRANS, LUPLO -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DLACPY, DLASCL, DLASET, DSCAL, DSYR2K, DTRMM, - $ XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDA.LT.1 .OR. ( LTRANS .AND. LDA.LT.N ) .OR. - $ ( .NOT.LTRANS .AND. LDA.LT.M ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.M*N ) - $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN - INFO = -14 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RU', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute W = op( A )*T or W = T*op( A ) in DWORK, and apply the -C updating formula (see METHOD section). -C Workspace: need M*N. -C - CALL DSCAL( N, HALF, X, LDX+1 ) -C - IF( LTRANS ) THEN -C - CALL DLACPY( 'Full', N, M, A, LDA, DWORK, N ) - CALL DTRMM( 'Left', UPLO, 'NoTranspose', 'Non-unit', N, M, - $ ONE, X, LDX, DWORK, N ) - CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, N, A, LDA, ALPHA, - $ R, LDR ) -C - ELSE -C - CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) - CALL DTRMM( 'Right', UPLO, 'NoTranspose', 'Non-unit', M, N, - $ ONE, X, LDX, DWORK, M ) - CALL DSYR2K( UPLO, TRANS, M, N, BETA, DWORK, M, A, LDA, ALPHA, - $ R, LDR ) -C - END IF -C - CALL DSCAL( N, TWO, X, LDX+1 ) -C - RETURN -C *** Last line of MB01RU *** - END
--- a/main/control/devel/ncfsyn/MB01RX.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,315 +0,0 @@ - SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, - $ A, LDA, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To compute either the upper or lower triangular part of one of the -C matrix formulas -C _ -C R = alpha*R + beta*op( A )*B, (1) -C _ -C R = alpha*R + beta*B*op( A ), (2) -C _ -C where alpha and beta are scalars, R and R are m-by-m matrices, -C op( A ) and B are m-by-n and n-by-m matrices for (1), or n-by-m -C and m-by-n matrices for (2), respectively, and op( A ) is one of -C -C op( A ) = A or op( A ) = A', the transpose of A. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the matrix A appears on the left or -C right in the matrix product as follows: -C _ -C = 'L': R = alpha*R + beta*op( A )*B; -C _ -C = 'R': R = alpha*R + beta*B*op( A ). -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the matrices R and R are -C computed and given, respectively, as follows: -C = 'U': the upper triangular part; -C = 'L': the lower triangular part. -C -C TRANS CHARACTER*1 -C Specifies the form of op( A ) to be used in the matrix -C multiplication as follows: -C = 'N': op( A ) = A; -C = 'T': op( A ) = A'; -C = 'C': op( A ) = A'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R and R, the number of rows of -C the matrix op( A ) and the number of columns of the -C matrix B, for SIDE = 'L', or the number of rows of the -C matrix B and the number of columns of the matrix op( A ), -C for SIDE = 'R'. M >= 0. -C -C N (input) INTEGER -C The number of rows of the matrix B and the number of -C columns of the matrix op( A ), for SIDE = 'L', or the -C number of rows of the matrix op( A ) and the number of -C columns of the matrix B, for SIDE = 'R'. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then A and B are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the matrix R; the strictly lower -C triangular part of the array is not referenced. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the matrix R; the strictly upper -C triangular part of the array is not referenced. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C A (input) DOUBLE PRECISION array, dimension (LDA,k), where -C k = N when SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T'; -C k = M when SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T'. -C On entry, if SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T', -C the leading M-by-N part of this array must contain the -C matrix A. -C On entry, if SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T', -C the leading N-by-M part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of array A. LDA >= MAX(1,l), where -C l = M when SIDE = 'L', and TRANS = 'N', or -C SIDE = 'R', and TRANS = 'T'; -C l = N when SIDE = 'R', and TRANS = 'N', or -C SIDE = 'L', and TRANS = 'T'. -C -C B (input) DOUBLE PRECISION array, dimension (LDB,p), where -C p = M when SIDE = 'L'; -C p = N when SIDE = 'R'. -C On entry, the leading N-by-M part, if SIDE = 'L', or -C M-by-N part, if SIDE = 'R', of this array must contain the -C matrix B. -C -C LDB INTEGER -C The leading dimension of array B. -C LDB >= MAX(1,N), if SIDE = 'L'; -C LDB >= MAX(1,M), if SIDE = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is evaluated taking the triangular -C structure into account. BLAS 2 operations are used. A block -C algorithm can be easily constructed; it can use BLAS 3 GEMM -C operations for most computations, and calls of this BLAS 2 -C algorithm for computing the triangles. -C -C FURTHER COMMENTS -C -C The main application of this routine is when the result should -C be a symmetric matrix, e.g., when B = X*op( A )', for (1), or -C B = op( A )'*X, for (2), where B is already available and X = X'. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C -C REVISIONS -C -C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDA, LDB, LDR, M, N - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS, LUPLO - INTEGER J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DGEMV, DLASCL, DLASET, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.1 .OR. - $ ( ( ( LSIDE .AND. .NOT.LTRANS ) .OR. - $ ( .NOT.LSIDE .AND. LTRANS ) ) .AND. LDA.LT.M ) .OR. - $ ( ( ( LSIDE .AND. LTRANS ) .OR. - $ ( .NOT.LSIDE .AND. .NOT.LTRANS ) ) .AND. LDA.LT.N ) ) THEN - INFO = -11 - ELSE IF( LDB.LT.1 .OR. - $ ( LSIDE .AND. LDB.LT.N ) .OR. - $ ( .NOT.LSIDE .AND. LDB.LT.M ) ) THEN - INFO = -13 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RX', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case alpha = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0 or N = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute the required triangle of (1) or (2) using BLAS 2 -C operations. -C - IF( LSIDE ) THEN - IF( LUPLO ) THEN - IF ( LTRANS ) THEN - DO 10 J = 1, M - CALL DGEMV( TRANS, N, J, BETA, A, LDA, B(1,J), 1, - $ ALPHA, R(1,J), 1 ) - 10 CONTINUE - ELSE - DO 20 J = 1, M - CALL DGEMV( TRANS, J, N, BETA, A, LDA, B(1,J), 1, - $ ALPHA, R(1,J), 1 ) - 20 CONTINUE - END IF - ELSE - IF ( LTRANS ) THEN - DO 30 J = 1, M - CALL DGEMV( TRANS, N, M-J+1, BETA, A(1,J), LDA, - $ B(1,J), 1, ALPHA, R(J,J), 1 ) - 30 CONTINUE - ELSE - DO 40 J = 1, M - CALL DGEMV( TRANS, M-J+1, N, BETA, A(J,1), LDA, - $ B(1,J), 1, ALPHA, R(J,J), 1 ) - 40 CONTINUE - END IF - END IF -C - ELSE - IF( LUPLO ) THEN - IF( LTRANS ) THEN - DO 50 J = 1, M - CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(J,1), - $ LDA, ALPHA, R(1,J), 1 ) - 50 CONTINUE - ELSE - DO 60 J = 1, M - CALL DGEMV( 'NoTranspose', J, N, BETA, B, LDB, A(1,J), - $ 1, ALPHA, R(1,J), 1 ) - 60 CONTINUE - END IF - ELSE - IF( LTRANS ) THEN - DO 70 J = 1, M - CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), - $ LDB, A(J,1), LDA, ALPHA, R(J,J), 1 ) - 70 CONTINUE - ELSE - DO 80 J = 1, M - CALL DGEMV( 'NoTranspose', M-J+1, N, BETA, B(J,1), - $ LDB, A(1,J), 1, ALPHA, R(J,J), 1 ) - 80 CONTINUE - END IF - END IF - END IF -C - RETURN -C *** Last line of MB01RX *** - END
--- a/main/control/devel/ncfsyn/MB01RY.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,429 +0,0 @@ - SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, - $ LDH, B, LDB, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To compute either the upper or lower triangular part of one of the -C matrix formulas -C _ -C R = alpha*R + beta*op( H )*B, (1) -C _ -C R = alpha*R + beta*B*op( H ), (2) -C _ -C where alpha and beta are scalars, H, B, R, and R are m-by-m -C matrices, H is an upper Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C The result is overwritten on R. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C _ -C = 'L': R = alpha*R + beta*op( H )*B; -C _ -C = 'R': R = alpha*R + beta*B*op( H ). -C -C UPLO CHARACTER*1 _ -C Specifies which triangles of the matrices R and R are -C computed and given, respectively, as follows: -C = 'U': the upper triangular part; -C = 'L': the lower triangular part. -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER _ -C The order of the matrices R, R, H and B. M >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then R need not be -C set before entry. -C -C BETA (input) DOUBLE PRECISION -C The scalar beta. When beta is zero then H and B are not -C referenced. -C -C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) -C On entry with UPLO = 'U', the leading M-by-M upper -C triangular part of this array must contain the upper -C triangular part of the matrix R; the strictly lower -C triangular part of the array is not referenced. -C On entry with UPLO = 'L', the leading M-by-M lower -C triangular part of this array must contain the lower -C triangular part of the matrix R; the strictly upper -C triangular part of the array is not referenced. -C On exit, the leading M-by-M upper triangular part (if -C UPLO = 'U'), or lower triangular part (if UPLO = 'L') of -C this array contains the corresponding triangular part of -C _ -C the computed matrix R. -C -C LDR INTEGER -C The leading dimension of array R. LDR >= MAX(1,M). -C -C H (input) DOUBLE PRECISION array, dimension (LDH,M) -C On entry, the leading M-by-M upper Hessenberg part of -C this array must contain the upper Hessenberg part of the -C matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of array H. LDH >= MAX(1,M). -C -C B (input) DOUBLE PRECISION array, dimension (LDB,M) -C On entry, the leading M-by-M part of this array must -C contain the matrix B. -C -C LDB INTEGER -C The leading dimension of array B. LDB >= MAX(1,M). -C -C Workspace -C -C DWORK DOUBLE PRECISION array, dimension (LDWORK) -C LDWORK >= M, if beta <> 0 and SIDE = 'L'; -C LDWORK >= 0, if beta = 0 or SIDE = 'R'. -C This array is not referenced when beta = 0 or SIDE = 'R'. -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The matrix expression is efficiently evaluated taking the -C Hessenberg/triangular structure into account. BLAS 2 operations -C are used. A block algorithm can be constructed; it can use BLAS 3 -C GEMM operations for most computations, and calls of this BLAS 2 -C algorithm for computing the triangles. -C -C FURTHER COMMENTS -C -C The main application of this routine is when the result should -C be a symmetric matrix, e.g., when B = X*op( H )', for (1), or -C B = op( H )'*X, for (2), where B is already available and X = X'. -C -C CONTRIBUTORS -C -C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix algebra, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS, UPLO - INTEGER INFO, LDB, LDH, LDR, M - DOUBLE PRECISION ALPHA, BETA -C .. Array Arguments .. - DOUBLE PRECISION B(LDB,*), DWORK(*), H(LDH,*), R(LDR,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS, LUPLO - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL DDOT, LSAME -C .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLASCL, DLASET, DSCAL, DSWAP, - $ DTRMV, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LUPLO = LSAME( UPLO, 'U' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = -2 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( LDR.LT.MAX( 1, M ) ) THEN - INFO = -8 - ELSE IF( LDH.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -12 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01RY', -INFO ) - RETURN - END IF -C -C Quick return if possible. -C - IF ( M.EQ.0 ) - $ RETURN -C - IF ( BETA.EQ.ZERO ) THEN - IF ( ALPHA.EQ.ZERO ) THEN -C -C Special case when both alpha = 0 and beta = 0. -C - CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) - ELSE -C -C Special case beta = 0. -C - IF ( ALPHA.NE.ONE ) - $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) - END IF - RETURN - END IF -C -C General case: beta <> 0. -C Compute the required triangle of (1) or (2) using BLAS 2 -C operations. -C - IF( LSIDE ) THEN -C -C To avoid repeated references to the subdiagonal elements of H, -C these are swapped with the corresponding elements of H in the -C first column, and are finally restored. -C - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - IF( LUPLO ) THEN - IF ( LTRANS ) THEN -C - DO 20 J = 1, M -C -C Multiply the transposed upper triangle of the leading -C j-by-j submatrix of H by the leading part of the j-th -C column of B. -C - CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, - $ DWORK, 1 ) -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 10 I = 1, MIN( J, M - 1 ) - R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) + - $ H( I+1, 1 )*B( I+1, J ) ) - 10 CONTINUE -C - 20 CONTINUE -C - R( M, M ) = ALPHA*R( M, M ) + BETA*DWORK( M ) -C - ELSE -C - DO 40 J = 1, M -C -C Multiply the upper triangle of the leading j-by-j -C submatrix of H by the leading part of the j-th column -C of B. -C - CALL DCOPY( J, B( 1, J ), 1, DWORK, 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', J, H, LDH, - $ DWORK, 1 ) - IF( J.LT.M ) THEN -C -C Multiply the remaining right part of the leading -C j-by-M submatrix of H by the trailing part of the -C j-th column of B. -C - CALL DGEMV( TRANS, J, M-J, BETA, H( 1, J+1 ), LDH, - $ B( J+1, J ), 1, ALPHA, R( 1, J ), 1 ) - ELSE - CALL DSCAL( M, ALPHA, R( 1, M ), 1 ) - END IF -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - R( 1, J ) = R( 1, J ) + BETA*DWORK( 1 ) -C - DO 30 I = 2, J - R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + - $ H( I, 1 )*B( I-1, J ) ) - 30 CONTINUE -C - 40 CONTINUE -C - END IF -C - ELSE -C - IF ( LTRANS ) THEN -C - DO 60 J = M, 1, -1 -C -C Multiply the transposed upper triangle of the trailing -C (M-j+1)-by-(M-j+1) submatrix of H by the trailing part -C of the j-th column of B. -C - CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, - $ H( J, J ), LDH, DWORK( J ), 1 ) - IF( J.GT.1 ) THEN -C -C Multiply the remaining left part of the trailing -C (M-j+1)-by-(j-1) submatrix of H' by the leading -C part of the j-th column of B. -C - CALL DGEMV( TRANS, J-1, M-J+1, BETA, H( 1, J ), - $ LDH, B( 1, J ), 1, ALPHA, R( J, J ), - $ 1 ) - ELSE - CALL DSCAL( M, ALPHA, R( 1, 1 ), 1 ) - END IF -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 50 I = J, M - 1 - R( I, J ) = R( I, J ) + BETA*( DWORK( I ) + - $ H( I+1, 1 )*B( I+1, J ) ) - 50 CONTINUE -C - R( M, J ) = R( M, J ) + BETA*DWORK( M ) - 60 CONTINUE -C - ELSE -C - DO 80 J = M, 1, -1 -C -C Multiply the upper triangle of the trailing -C (M-j+1)-by-(M-j+1) submatrix of H by the trailing -C part of the j-th column of B. -C - CALL DCOPY( M-J+1, B( J, J ), 1, DWORK( J ), 1 ) - CALL DTRMV( 'Upper', TRANS, 'Non-unit', M-J+1, - $ H( J, J ), LDH, DWORK( J ), 1 ) -C -C Add the contribution of the subdiagonal of H to -C the j-th column of the product. -C - DO 70 I = MAX( J, 2 ), M - R( I, J ) = ALPHA*R( I, J ) + BETA*( DWORK( I ) - $ + H( I, 1 )*B( I-1, J ) ) - 70 CONTINUE -C - 80 CONTINUE -C - R( 1, 1 ) = ALPHA*R( 1, 1 ) + BETA*DWORK( 1 ) -C - END IF - END IF -C - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C -C Row-wise calculations are used for H, if SIDE = 'R' and -C TRANS = 'T'. -C - IF( LUPLO ) THEN - IF( LTRANS ) THEN - R( 1, 1 ) = ALPHA*R( 1, 1 ) + - $ BETA*DDOT( M, B, LDB, H, LDH ) -C - DO 90 J = 2, M - CALL DGEMV( 'NoTranspose', J, M-J+2, BETA, - $ B( 1, J-1 ), LDB, H( J, J-1 ), LDH, - $ ALPHA, R( 1, J ), 1 ) - 90 CONTINUE -C - ELSE -C - DO 100 J = 1, M - 1 - CALL DGEMV( 'NoTranspose', J, J+1, BETA, B, LDB, - $ H( 1, J ), 1, ALPHA, R( 1, J ), 1 ) - 100 CONTINUE -C - CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, - $ H( 1, M ), 1, ALPHA, R( 1, M ), 1 ) -C - END IF -C - ELSE -C - IF( LTRANS ) THEN -C - CALL DGEMV( 'NoTranspose', M, M, BETA, B, LDB, H, LDH, - $ ALPHA, R( 1, 1 ), 1 ) -C - DO 110 J = 2, M - CALL DGEMV( 'NoTranspose', M-J+1, M-J+2, BETA, - $ B( J, J-1 ), LDB, H( J, J-1 ), LDH, ALPHA, - $ R( J, J ), 1 ) - 110 CONTINUE -C - ELSE -C - DO 120 J = 1, M - 1 - CALL DGEMV( 'NoTranspose', M-J+1, J+1, BETA, - $ B( J, 1 ), LDB, H( 1, J ), 1, ALPHA, - $ R( J, J ), 1 ) - 120 CONTINUE -C - R( M, M ) = ALPHA*R( M, M ) + - $ BETA*DDOT( M, B( M, 1 ), LDB, H( 1, M ), 1 ) -C - END IF - END IF - END IF -C - RETURN -C *** Last line of MB01RY *** - END
--- a/main/control/devel/ncfsyn/MB01SD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ - SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/MB01UD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,238 +0,0 @@ - SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, - $ LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To compute one of the matrix products -C -C B = alpha*op( H ) * A, or B = alpha*A * op( H ), -C -C where alpha is a scalar, A and B are m-by-n matrices, H is an -C upper Hessenberg matrix, and op( H ) is one of -C -C op( H ) = H or op( H ) = H', the transpose of H. -C -C ARGUMENTS -C -C Mode Parameters -C -C SIDE CHARACTER*1 -C Specifies whether the Hessenberg matrix H appears on the -C left or right in the matrix product as follows: -C = 'L': B = alpha*op( H ) * A; -C = 'R': B = alpha*A * op( H ). -C -C TRANS CHARACTER*1 -C Specifies the form of op( H ) to be used in the matrix -C multiplication as follows: -C = 'N': op( H ) = H; -C = 'T': op( H ) = H'; -C = 'C': op( H ) = H'. -C -C Input/Output Parameters -C -C M (input) INTEGER -C The number of rows of the matrices A and B. M >= 0. -C -C N (input) INTEGER -C The number of columns of the matrices A and B. N >= 0. -C -C ALPHA (input) DOUBLE PRECISION -C The scalar alpha. When alpha is zero then H is not -C referenced and A need not be set before entry. -C -C H (input) DOUBLE PRECISION array, dimension (LDH,k) -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C On entry with SIDE = 'L', the leading M-by-M upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C On entry with SIDE = 'R', the leading N-by-N upper -C Hessenberg part of this array must contain the upper -C Hessenberg matrix H. -C The elements below the subdiagonal are not referenced, -C except possibly for those in the first column, which -C could be overwritten, but are restored on exit. -C -C LDH INTEGER -C The leading dimension of the array H. LDH >= max(1,k), -C where k is M when SIDE = 'L' and is N when SIDE = 'R'. -C -C A (input) DOUBLE PRECISION array, dimension (LDA,N) -C The leading M-by-N part of this array must contain the -C matrix A. -C -C LDA INTEGER -C The leading dimension of the array A. LDA >= max(1,M). -C -C B (output) DOUBLE PRECISION array, dimension (LDB,N) -C The leading M-by-N part of this array contains the -C computed product. -C -C LDB INTEGER -C The leading dimension of the array B. LDB >= max(1,M). -C -C Error Indicator -C -C INFO INTEGER -C = 0: successful exit; -C < 0: if INFO = -i, the i-th argument had an illegal -C value. -C -C METHOD -C -C The required matrix product is computed in two steps. In the first -C step, the upper triangle of H is used; in the second step, the -C contribution of the subdiagonal is added. A fast BLAS 3 DTRMM -C operation is used in the first step. -C -C CONTRIBUTOR -C -C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. -C -C REVISIONS -C -C - -C -C KEYWORDS -C -C Elementary matrix operations, matrix operations. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -C .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, LDA, LDB, LDH, M, N - DOUBLE PRECISION ALPHA -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), H(LDH,*) -C .. Local Scalars .. - LOGICAL LSIDE, LTRANS - INTEGER I, J -C .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -C .. External Subroutines .. - EXTERNAL DAXPY, DLACPY, DLASET, DSWAP, DTRMM, XERBLA -C .. Intrinsic Functions .. - INTRINSIC MAX, MIN -C -C .. Executable Statements .. -C -C Test the input scalar arguments. -C - INFO = 0 - LSIDE = LSAME( SIDE, 'L' ) - LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) -C - IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = -1 - ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. - $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN - INFO = -7 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( LDB.LT.MAX( 1, M ) ) THEN - INFO = -11 - END IF -C - IF ( INFO.NE.0 ) THEN -C -C Error return. -C - CALL XERBLA( 'MB01UD', -INFO ) - RETURN - END IF -C -C Quick return, if possible. -C - IF ( MIN( M, N ).EQ.0 ) - $ RETURN -C - IF( ALPHA.EQ.ZERO ) THEN -C -C Set B to zero and return. -C - CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) - RETURN - END IF -C -C Copy A in B and compute one of the matrix products -C B = alpha*op( triu( H ) ) * A, or -C B = alpha*A * op( triu( H ) ), -C involving the upper triangle of H. -C - CALL DLACPY( 'Full', M, N, A, LDA, B, LDB ) - CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, - $ LDH, B, LDB ) -C -C Add the contribution of the subdiagonal of H. -C If SIDE = 'L', the subdiagonal of H is swapped with the -C corresponding elements in the first column of H, and the -C calculations are organized for column operations. -C - IF( LSIDE ) THEN - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) - IF( LTRANS ) THEN - DO 20 J = 1, N - DO 10 I = 1, M - 1 - B( I, J ) = B( I, J ) + ALPHA*H( I+1, 1 )*A( I+1, J ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 2, M - B( I, J ) = B( I, J ) + ALPHA*H( I, 1 )*A( I-1, J ) - 30 CONTINUE - 40 CONTINUE - END IF - IF( M.GT.2 ) - $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) -C - ELSE -C - IF( LTRANS ) THEN - DO 50 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J ), 1, - $ B( 1, J+1 ), 1 ) - 50 CONTINUE - ELSE - DO 60 J = 1, N - 1 - IF ( H( J+1, J ).NE.ZERO ) - $ CALL DAXPY( M, ALPHA*H( J+1, J ), A( 1, J+1 ), 1, - $ B( 1, J ), 1 ) - 60 CONTINUE - END IF - END IF -C - RETURN -C *** Last line of MB01UD *** - END
--- a/main/control/devel/ncfsyn/MB02PD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,553 +0,0 @@ - SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, - $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, - $ IWORK, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve (if well-conditioned) the matrix equations -C -C op( A )*X = B, -C -C where X and B are N-by-NRHS matrices, A is an N-by-N matrix and -C op( A ) is one of -C -C op( A ) = A or op( A ) = A'. -C -C Error bounds on the solution and a condition estimate are also -C provided. -C -C ARGUMENTS -C -C Mode Parameters -C -C FACT CHARACTER*1 -C Specifies whether or not the factored form of the matrix A -C is supplied on entry, and if not, whether the matrix A -C should be equilibrated before it is factored. -C = 'F': On entry, AF and IPIV contain the factored form -C of A. If EQUED is not 'N', the matrix A has been -C equilibrated with scaling factors given by R -C and C. A, AF, and IPIV are not modified. -C = 'N': The matrix A will be copied to AF and factored. -C = '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 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 - -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 .. Save Statement .. - SAVE RPVGRW -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 - 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
--- a/main/control/devel/ncfsyn/MB02VD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,187 +0,0 @@ - SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To compute the 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
--- a/main/control/devel/ncfsyn/SB02MR.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ - LOGICAL FUNCTION SB02MR( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/SB02MS.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,79 +0,0 @@ - LOGICAL FUNCTION SB02MS( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/SB02MV.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,75 +0,0 @@ - LOGICAL FUNCTION SB02MV( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/SB02MW.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,79 +0,0 @@ - LOGICAL FUNCTION SB02MW( REIG, IEIG ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/SB02OD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,856 +0,0 @@ - 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 SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve for X either the 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 stricly lower triangular part (if -C UPLO = 'U') or stricly 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 stricly lower triangular -C part (if UPLO = 'U') or stricly 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 stricly lower triangular -C part (if UPLO = 'U') or stricly 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
--- a/main/control/devel/ncfsyn/SB02OU.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ - LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/SB02OV.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,88 +0,0 @@ - LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -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
--- a/main/control/devel/ncfsyn/SB02OW.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ - LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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
--- a/main/control/devel/ncfsyn/SB02OY.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,791 +0,0 @@ - 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 SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To construct 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 stricly lower triangular part (if -C UPLO = 'U') or stricly 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 stricly lower triangular -C part (if UPLO = 'U') or stricly 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 stricly lower triangular -C part (if UPLO = 'U') or stricly 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
--- a/main/control/devel/ncfsyn/SB02QD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,804 +0,0 @@ - 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 SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 Error 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 -C KEYWORDS -C -C Conditioning, error estimates, orthogonal transformation, -C real Schur form, Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.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, 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 ) -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, DLACON, 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 IF( LDWORK.LT.MAX( 1, LDW ) ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02QD', -INFO ) - 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 - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - 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 DLACON( NN, DWORK( ITMP+1 ), DWORK, IWORK, EST, KASE ) - 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
--- a/main/control/devel/ncfsyn/SB02RD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1133 +0,0 @@ - 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 SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve for X either the 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
--- a/main/control/devel/ncfsyn/SB02RU.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,508 +0,0 @@ - SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q, - $ LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To construct 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
--- a/main/control/devel/ncfsyn/SB02SD.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,859 +0,0 @@ - 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 SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 Error 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 -C KEYWORDS -C -C Conditioning, error estimates, orthogonal transformation, -C real Schur form, Riccati equation. -C -C ****************************************************************** -C -C .. Parameters .. - DOUBLE PRECISION ZERO, ONE, TWO, FOUR, HALF - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.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, 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 ) -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, DLACON, - $ 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 IF( LDWORK.LT.LDW ) THEN - INFO = -24 - END IF -C - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SB02SD', -INFO ) - 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 - IF( UPDATE ) THEN - SJOB = 'V' - ELSE - SJOB = 'N' - END IF - 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 DLACON( NN, DWORK( IXBS+1 ), DWORK, IWORK, EST, KASE ) - 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
--- a/main/control/devel/ncfsyn/SB03MV.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,295 +0,0 @@ - SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, - $ XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve for 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, 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( 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
--- a/main/control/devel/ncfsyn/SB03MW.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,293 +0,0 @@ - SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, - $ XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve for 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
--- a/main/control/devel/ncfsyn/SB03MX.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,711 +0,0 @@ - SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve 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
--- a/main/control/devel/ncfsyn/SB03MY.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,613 +0,0 @@ - SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve 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
--- a/main/control/devel/ncfsyn/SB03QX.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,394 +0,0 @@ - SUBROUTINE SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 -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 .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, 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 DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - 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
--- a/main/control/devel/ncfsyn/SB03QY.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,443 +0,0 @@ - SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, - $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 -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 .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, 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 DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - 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 DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - 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
--- a/main/control/devel/ncfsyn/SB03SX.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,398 +0,0 @@ - SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, - $ R, LDR, FERR, IWORK, DWORK, LDWORK, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 -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 .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLANSY - EXTERNAL DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, 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 DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - 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
--- a/main/control/devel/ncfsyn/SB03SY.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,451 +0,0 @@ - SUBROUTINE SB03SY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, XA, - $ LDXA, SEPD, THNORM, IWORK, DWORK, LDWORK, - $ INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To 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 -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 .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL DLAMCH, DLANSY, LSAME -C .. -C .. External Subroutines .. - EXTERNAL DLACON, 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 DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - 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 DLACON( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE ) - 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
--- a/main/control/devel/ncfsyn/SB04PX.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,468 +0,0 @@ - SUBROUTINE SB04PX( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, - $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C PURPOSE -C -C To solve for 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
--- a/main/control/devel/ncfsyn/select.f Fri Aug 05 12:14:15 2011 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ - LOGICAL FUNCTION SELECT( PAR1, PAR2 ) -C -C SLICOT RELEASE 5.0. -C -C Copyright (c) 2002-2010 NICONET e.V. -C -C This program is free software: you can redistribute it and/or -C modify it under the terms of the GNU General Public License as -C published by the Free Software Foundation, either version 2 of -C the License, or (at your option) any later version. -C -C This program is distributed in the hope that it will be useful, -C but WITHOUT ANY WARRANTY; without even the implied warranty of -C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -C GNU General Public License for more details. -C -C You should have received a copy of the GNU General Public License -C along with this program. If not, see -C <http://www.gnu.org/licenses/>. -C -C Void logical function for DGEES. -C - DOUBLE PRECISION PAR1, PAR2 -C - SELECT = .TRUE. - RETURN - END
--- a/main/control/doc/NEWS Fri Aug 05 12:14:15 2011 +0000 +++ b/main/control/doc/NEWS Fri Aug 05 12:34:08 2011 +0000 @@ -1,17 +1,29 @@ Summary of important user-visible changes for releases of the control package =============================================================================== +control-2.x.yy Release Date: 2011-xx-yy 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". + +=============================================================================== control-2.1.52 Release Date: 2011-07-27 Release Manager: Lukas Reichlin =============================================================================== -** hsvd.m +** hsvd -- Use scaling unless state-space model property "scaled" is set to true. -** @lti/norm.m +** @lti/norm -- Use scaling for computation of L-infinity norm unless state-space model property "scaled" is set to true. -** @lti/minreal.m +** @lti/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 @@ -19,11 +31,11 @@ reduction occurs. This is achieved by saving the system matrices before each phase and restoring them if no order reduction took place. -** @lti/zero.m +** @lti/zero -- Use scaling for state-space and descriptor state-space models unless property "scaled" is set to true. -** @lti/frdata.m +** @lti/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. @@ -34,7 +46,7 @@ control-2.1.51 Release Date: 2011-07-21 Release Manager: Lukas Reichlin =============================================================================== -** frd.m +** frd -- Support for Frequency Response Data (frd) measurement "models". @@ -42,14 +54,14 @@ control-2.1.50 Release Date: 2011-07-06 Release Manager: Lukas Reichlin =============================================================================== -** ss.m +** ss -- Support for property "scaled". By default, it is set to "false". -** @lti/prescale.m +** @lti/prescale -- Scaling for state-space models (SLICOT TB01ID) and descriptor models (SLICOT TG01AD). -** @lti/freqresp.m +** @lti/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". @@ -59,7 +71,7 @@ control-2.0.2 Release Date: 2011-03-18 Release Manager: Lukas Reichlin =============================================================================== -** lsim.m +** 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) @@ -69,11 +81,11 @@ control-2.0.1 Release Date: 2011-03-06 Release Manager: Lukas Reichlin =============================================================================== -** lsim.m +** lsim -- Support time vectors not starting at zero. (Thanks to Rob Frohne) -- Improved help text. -** @lti/zero.m +** @lti/zero -- The gain of descriptor state-space models is now computed correctly. (fingers crossed)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/main/control/inst/MDSSystem.m Fri Aug 05 12:34:08 2011 +0000 @@ -0,0 +1,156 @@ +% =============================================================================== +% 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(4, 4); % 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 +figure (1) + +for k = 1 : numel (delta_m) + Delta = diag ([delta_m(k), delta_c(k), delta_k(k)]); + G_per = lft (Delta, G_nom); + bode (G_per, w) + subplot (2, 1, 1) + hold on + subplot (2, 1, 2) + hold on +endfor + + +% =============================================================================== +% 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 = mixsyn (G, W_p, W_u); % mixed-sensitivity H-infinity synthesis + +% Interconnections +L = G * K; % open loop +T = feedback (L); % closed loop + +% Plotting +figure (2) +sigma (T) % singular values + +figure (3) +step (T) % step response + + +% =============================================================================== +% H-infinity Loop-Shaping Design +% =============================================================================== + +% Settings +W1 = 8 * (2*s + 1) / (0.9*s); % precompensator +W2 = 1; % postcompensator +factor = 1.1; % suboptimal controller + +% Synthesis +K = ncfsyn (G, W1, W2, factor); % positive feedback controller + +% Interconnections +K = -K; % negative feedback controller +L = G * K; % open loop +T = feedback (L); % closed loop + +% Plotting +figure (4) +sigma (T) % singular values + +figure (5) +step (T) % step response + +% ===============================================================================